home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / UTILITY / STORUTIL.I < prev    next >
Encoding:
Modula Implementation  |  1994-06-03  |  13.0 KB  |  430 lines
  1. IMPLEMENTATION MODULE StorUtils;
  2. (*------------------------------------------------------------------------*)
  3. (* Debuggingroutien mit Hilfe von Storage                                 *)
  4. (* Erstellt unter Verwendung von NewStorTest                              *)
  5. (*------------------------------------------------------------------------*)
  6. (* Autor:                                                                 *)
  7. (* Gerd Castan, Hoehbergstr. 16, 70327 Stuttgart                          *)
  8. (* EMail: G.Castan@physik.uni-stuttgart.de                                *)
  9. (*------------------------------------------------------------------------*)
  10. (* Version | Datum    | Arbeitsbericht                                    *)
  11. (* 1.01    | 26.03.94 | Addr/Block/BlockExactInStorage,findBlock          *)
  12. (* 2.01    | 26.03.94 | GetAllocInfo,TestStorage                          *)
  13. (* 2.02    | 27.03.94 | Zum Betatest Freigegeben von Gc                   *)
  14. (* 2.03    | 27.03.94 | findBlock entwanzt; Freigegeben von Gc            *)
  15. (*------------------------------------------------------------------------*)
  16.  
  17. FROM SYSTEM IMPORT ASSEMBLER, ADDRESS, ADR, BYTE;
  18. FROM Storage IMPORT More;
  19. FROM StorBase IMPORT Inconsistent, FullStorBaseAccess, MemSize;
  20.  
  21. (*------------------------------------------------------------------------*)
  22. (* Datenstrukturen aus NewStorTest                                        *)
  23. (*------------------------------------------------------------------------*)
  24.  
  25. TYPE
  26.         PtrHead = POINTER TO Head;
  27.  
  28.         HeadLink = RECORD
  29.                      n: INTEGER;  (* rel. offset von block.data *)
  30.                      p: INTEGER;  (* rel. offset von block.data *)
  31.                    END;
  32.  
  33.         Head  = RECORD;           (* werden nur für used-Bereiche benutzt *)
  34.                   hd: HeadLink;
  35.                   root: INTEGER;  (* rel. Offset von Block.data (pos.Wert) *)
  36.                   level: INTEGER;
  37.                   size: INTEGER;  (* used-Größe, kann ungerade sein!     *)
  38.                                   (* -- muß immer vor 'hd.data' stehen   *)
  39.                                   (* damit 'fullBlk' funktioniert!       *)
  40.                   data: BYTE      (* Beginn der Daten *)
  41.                 END;
  42. CONST
  43.         HeadSize = 10;            (* TSIZE (Head ohne data) *)
  44.  
  45. TYPE
  46.         PtrLink = POINTER TO Link;
  47.  
  48.         Link = RECORD
  49.                  next: PtrLink;
  50.                  prev: PtrLink;
  51.                END;
  52.  
  53.         PtrBlock = POINTER TO Block;
  54.  
  55.         Block = RECORD
  56.                   blk: Link;
  57.                   size: LONGINT;  (* Größe des verfügbaren Bereichs *)
  58.                                   (*  kann ungerade sein!           *)
  59.                                   (* Bit 30: <full>                 *)
  60.                   CASE : CARDINAL OF
  61.                   | 0: (* full *)
  62.                     level: INTEGER;
  63.                     full: CARDINAL; (* = 0, wenn full *)
  64.                     fullData: BYTE
  65.                   | 1: (* root *)
  66.                     blRov: PtrBlock (* zeigt direkt auf letzten Block *)
  67.                   | 2: (* not full *)
  68.                     hd: HeadLink;
  69.                     hdRov: INTEGER; (* letzer hd, wo alloc durchgef. wurde *)
  70.                     free: LONGINT;  (* gesamter freier Bereich in Block *)
  71.                     hds : BYTE      (* Beginn der Header/Freibereiche *)
  72.                   END
  73.                 END;
  74. CONST
  75.         BlockSize     = 22;  (* TSIZE (Block ohne hds) *)
  76.         BlockFullSize = 16;  (* TSIZE (Block, 0) *)
  77.  
  78. VAR RootPtr: PtrBlock;
  79.  
  80. (*------------------------------------------------------------------------*)
  81. (* Zugriff auf Datenstrukturen aus NewStorTest                            *)
  82. (*------------------------------------------------------------------------*)
  83.  
  84. PROCEDURE abs (bl: PtrBlock; hd: INTEGER): ADDRESS;
  85.   (*$L-*)
  86.   BEGIN
  87.     ASSEMBLER
  88.         ; RETURN ADR (bl^.hds) + LONGCARD (LONG (hd))
  89.         MOVE    -(A3),D0
  90.         MOVE.L  -(A3),A0
  91.         ADDA.W  D0,A0
  92.         ADDA.W  #BlockSize,A0
  93.         MOVE.L  A0,(A3)+
  94.     END
  95.   END abs;
  96.   (*$L=*)
  97.  
  98. PROCEDURE sizeHd (bl: PtrBlock; hd: INTEGER): INTEGER;
  99.   (*$L-*)
  100.   BEGIN
  101.     ASSEMBLER
  102.         ; hdp:= abs (bl, hd);
  103.         ; RETURN val (hdp^.size)
  104.         MOVE    -(A3),D0
  105.         MOVE.L  -(A3),A0
  106.         MOVE.W  Head.size+BlockSize(A0,D0.W),D0
  107.         ADDQ    #1,D0
  108.         ANDI    #$FFFE,D0
  109.         MOVE    D0,(A3)+
  110.     END;
  111.   END sizeHd;
  112.   (*$L=*)
  113.  
  114. PROCEDURE blkFull (bl: PtrBlock): BOOLEAN;
  115.   (*$L-*)
  116.   BEGIN
  117.     ASSEMBLER
  118.         MOVE.L  -(A3),A0
  119.         BTST    #6,Block.size(A0)
  120.         SNE     D0
  121.         ANDI    #1,D0
  122.         MOVE    D0,(A3)+
  123.     END
  124.   END blkFull;
  125.   (*$L=*)
  126.  
  127. PROCEDURE blkSize (bl: PtrBlock): LONGINT;
  128.   (*$L-*)
  129.   BEGIN
  130.     ASSEMBLER
  131.         MOVE.L  -(A3),A0
  132.         MOVE.L  Block.size(A0),D0
  133.         ANDI.L  #$00FFFFFF,D0
  134.         MOVE.L  D0,(A3)+
  135.     END
  136.   END blkSize;
  137.   (*$L=*)
  138.  
  139. PROCEDURE nextHd (bl: PtrBlock; hd: INTEGER): INTEGER;
  140.   (*$L-*)
  141.   BEGIN
  142.     ASSEMBLER
  143.         ; hdp:= abs (bl, hd);
  144.         ; RETURN hdp^.hd.n
  145.         MOVE    -(A3),D0
  146.         MOVE.L  -(A3),A0
  147.         MOVE.W  Head.hd.n+BlockSize(A0,D0.W),(A3)+
  148.     END;
  149.   END nextHd;
  150.   (*$L=*)
  151.  
  152. (*------------------------------------------------------------------------*)
  153. (* Interne Prozeduren                                                     *)
  154. (*------------------------------------------------------------------------*)
  155.  
  156. PROCEDURE
  157.   findBlock (addr: ADDRESS; VAR full: BOOLEAN; VAR size: LONGINT): PtrBlock;
  158.   (* Sucht in den internen Datenstrukturen nach dem Block, der adr enthält.
  159.    * Dabei ist es unerheblich, ob sdr zur internen Verwaltung gehört oder
  160. nicht.
  161.    * Wenn kein Block gefunden wurde, oder adr innerhalb RootPtr^ ist,
  162.    * wird NIL zurückgegeben.
  163.    * full: Block ist nicht weiter unterteilt.
  164.    *)
  165.   VAR
  166.     bl: PtrBlock;
  167.     count: CARDINAL;  (* Zur Sicherheit Endlosschleife vermeiden *)
  168. BEGIN
  169.   count := 0;
  170.   bl:= RootPtr;
  171.   IF bl=NIL THEN RETURN NIL END;                    (* Nur zur Sicherheit *)
  172.   LOOP
  173.     (* Alles durchsucht oder Fehler? *)
  174.     bl:= ADDRESS (bl^.blk.next);
  175.     IF bl=NIL THEN RETURN NIL END;                  (* Nur zur Sicherheit *)
  176.     IF bl = RootPtr THEN RETURN NIL END;
  177.  
  178.     full := blkFull(bl);
  179.     (* addr innerhalb Block? *)
  180.     IF full THEN
  181.       IF (LONGINT(ADR(bl^.fullData))<=LONGINT(addr))
  182.       AND (LONGINT(addr)<LONGINT(ADR(bl^.fullData))+blkSize(bl)) THEN
  183.         size := blkSize(bl);
  184.         RETURN bl
  185.       END;
  186.     ELSE
  187.       IF (LONGINT(ADR(bl^.hds))<=LONGINT(addr))
  188.       AND (LONGINT(addr)<LONGINT(ADR(bl^.hds))+blkSize(bl)) THEN
  189.         size := blkSize(bl);
  190.         RETURN bl
  191.       END;
  192.     END;
  193.  
  194.     (* Endlosschleife? *)
  195.     INC (count);
  196.     IF count=MAX(CARDINAL) THEN RETURN NIL END;
  197.   END;
  198. END findBlock;
  199.  
  200.  
  201. PROCEDURE
  202.   findHead (bl: PtrBlock; addr: ADDRESS; VAR hd: PtrHead; VAR size: INTEGER);
  203.   VAR
  204.     freeBeg, usedBeg: INTEGER;
  205.     ad              : ADDRESS;
  206. BEGIN
  207.   freeBeg:= 0;            (* End of last used area *)
  208.   usedBeg:= bl^.hd.n;     (* Start of new used area *)
  209.   LOOP
  210.     IF usedBeg < 0 THEN
  211.       (* rest ist höchstens frei *)
  212.       (*RETURN*)
  213.     ELSE
  214.  
  215.     END;
  216.     hd:= abs (bl, usedBeg);
  217.  
  218.     (* addr innerhalb des allocierten Bereichs? *)
  219.     ad:= ADR (hd^.data);
  220.     IF (LONGINT(ad)<=LONGINT(addr))
  221.     AND (LONGINT(addr)<=LONGINT(ad)+LONG(hd^.size)) THEN
  222.       (* Gefunden: *)
  223.       size := hd^.size;
  224.       RETURN
  225.     END;
  226.  
  227.     IF usedBeg < 0 THEN
  228.       (* rest ist höchstens frei *)
  229.       hd := NIL; size := 0;
  230.       RETURN
  231.     END;
  232.  
  233.     freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
  234.     usedBeg:= nextHd (bl, usedBeg)
  235.   END
  236. END findHead;
  237.  
  238.  
  239. (*------------------------------------------------------------------------*)
  240. (* Exportierte Prozeduren                                                 *)
  241. (*------------------------------------------------------------------------*)
  242.  
  243.  
  244. PROCEDURE GetAllocInfo (addr: ADDRESS; VAR start: ADDRESS; VAR size: LONGCARD);
  245.   (* Wenn addr zu einem Speicherblock gehört, der mit Storage.ALLOCATE
  246.    * angefordert wurde, gibt start den Beginn und size die Länge dieses
  247.    * Speicherblocks an, sonst ist start=NIL und size=0.
  248.    *)
  249. VAR
  250.     bl: PtrBlock;
  251.     hd: PtrHead;
  252.     l : INTEGER;
  253.     full: BOOLEAN;
  254.     blsize: LONGINT;
  255. BEGIN
  256.   bl := findBlock(addr, full, blsize);
  257.  
  258.   (* Gar kein Block gefunden? *)
  259.   IF bl=NIL THEN start := NIL; size := 0; RETURN END;
  260.  
  261.   (* Block nicht weiter unterteilt? *)
  262.   IF full THEN
  263.     start := ADR(bl^.fullData);
  264.     size := VAL(LONGCARD, blsize);
  265.     RETURN
  266.   END;
  267.  
  268.   (* Innerhalb des Blocks weitersuchen: *)
  269.   findHead (bl, addr, hd, l);
  270.   IF hd=NIL THEN start := NIL; size := 0; RETURN END;
  271.  
  272.   start := ADR (hd^.data);
  273.   (*size := VAL (LONGCARD, LONG(hd^.size));*)
  274.   size := VAL (LONGCARD, LONG(l));
  275. END GetAllocInfo;
  276.  
  277.  
  278. PROCEDURE AddrInStorage (addr: ADDRESS): BOOLEAN;
  279.   (* Gehört addr zu einem Speicherblock, der mit Storage.ALLOCATE angefordert
  280.    * wurde?
  281.    *)
  282.   VAR
  283.     start : ADDRESS;
  284.     blsize: LONGCARD;
  285. BEGIN
  286.   GetAllocInfo (addr, start, blsize);
  287.   RETURN start#NIL
  288. END AddrInStorage;
  289.  
  290.  
  291. PROCEDURE BlockInStorage (addr: ADDRESS; size: LONGCARD): BOOLEAN;
  292.   (* Paßt addr in einen Speicherblock, der mit Storage.ALLOCATE angefordert
  293.    * wurde?
  294.    *)
  295.   VAR
  296.     start : ADDRESS;
  297.     blsize: LONGCARD;
  298. BEGIN
  299.   GetAllocInfo (addr, start, blsize);
  300.  
  301.   (* Gar kein Block gefunden? *)
  302.   IF start=NIL THEN RETURN FALSE END;
  303.  
  304.   RETURN (LONGCARD(start)<=LONGCARD(addr)) AND
  305.          (LONGCARD(addr)+size<=LONGCARD(start)+blsize)
  306.  
  307. END BlockInStorage;
  308.  
  309.  
  310. PROCEDURE BlockExactInStorage (addr: ADDRESS; size: LONGCARD): BOOLEAN;
  311.   (* Paßt addr exakt in einen Speicherblock, der mit Storage.ALLOCATE
  312.    * angefordert wurde?
  313.    *)
  314. VAR
  315.     start : ADDRESS;
  316.     blsize: LONGCARD;
  317. BEGIN
  318.   GetAllocInfo (addr, start, blsize);
  319.  
  320.   (* Gar kein Block gefunden? *)
  321.   IF start=NIL THEN RETURN FALSE END;
  322.  
  323.   RETURN (LONGCARD(start)=LONGCARD(addr)) AND
  324.          (LONGCARD(addr)+size=LONGCARD(start)+blsize)
  325.  
  326. END BlockExactInStorage;
  327.  
  328.  
  329. PROCEDURE TestStorage (): StorageError;
  330.   (* Unterzieht die interne Speicherverwaltung von Storage einem
  331.    * Plausibilitätstest.
  332.    * Wird storageOk zurückgegeben, ist (wahrscheinlich) alles in Ordnung.
  333.    *
  334.    * Wenn nicht, gibt es dafür 2 mögliche Ursachen:
  335.    * - Ein Fehler in Storage.
  336.    *   In diesem Fall geben die Fehlermeldungen an, wo der Fehler zu suchen ist.
  337.    * - Wahrscheinlicher: Ihr Programm oder ein parallel laufendes Programm
  338.    *   hat wild in den Speicher geschrieben.
  339.    *   In diesem Fall zählt nur, ob storageOk oder etwas anderes
  340.    *   zurückgegeben wurde.
  341.    *   Welcher Fehler zurückgegeben wird ist hier uninteressant.
  342.    *)
  343.   VAR
  344.     bl    : PtrBlock;
  345.     blPrev: PtrBlock;
  346.     count : CARDINAL;  (* Zur Sicherheit Endlosschleife vermeiden *)
  347.     full  : BOOLEAN;
  348.     fullStorBaseAccess: BOOLEAN;
  349.     freeBeg, usedBeg  : INTEGER;
  350.     hd                : PtrHead;
  351.     prevHd            : PtrHead;
  352. BEGIN
  353.   IF Inconsistent() THEN RETURN storageInconsistent END;
  354.   fullStorBaseAccess := FullStorBaseAccess();
  355.  
  356.   count := 0;
  357.   bl:= RootPtr;
  358.   IF bl=NIL THEN RETURN storageNIL END;
  359.   LOOP
  360.     blPrev := bl;
  361.     bl:= ADDRESS (bl^.blk.next);
  362.  
  363.     (* Vorwärtsverkettung endet bei RootPtr *)
  364.     IF bl=NIL THEN RETURN storageNIL END;
  365.  
  366.     (* bl ungerade? *)
  367.     IF LONGCARD(bl) MOD 2 = 1 THEN
  368.       RETURN storageOdd
  369.     END;
  370.  
  371.     (* Rückwärtsverkettung testen: *)
  372.     IF PtrBlock(bl^.blk.prev)#blPrev THEN
  373.       RETURN storagePrev1
  374.     END;
  375.  
  376.     (* Fertig? *)
  377.     IF bl = RootPtr THEN RETURN storageOK END;
  378.  
  379.     IF fullStorBaseAccess AND (MemSize(bl)=0) THEN
  380.       (* Block scheint nicht über StorBase.ALLOCATE geholt worden zu sein *)
  381.       RETURN storageNotAlloc
  382.     END;
  383.  
  384.     full := blkFull(bl);
  385.     IF ~full THEN
  386.       (* Block ist granuliert: *)
  387.       freeBeg:= 0;            (* End of last used area *)
  388.       usedBeg:= bl^.hd.n;     (* Start of new used area *)
  389.       hd := NIL;
  390.       LOOP
  391.         IF usedBeg < 0 THEN
  392.           (* rest ist höchstens frei *)
  393.           EXIT
  394.         END;
  395.  
  396.         prevHd := hd;
  397.         hd:= abs (bl, usedBeg);
  398.  
  399.         (* Rückwärtsverkettung testen: *)
  400.         IF (prevHd#NIL)
  401.         AND (abs (bl, hd^.hd.p)#prevHd) THEN
  402.           RETURN storagePrev2
  403.         END;
  404.  
  405.         (* Zeiger auf nächstes muß größer als Zeiger auf aktuelles sein: *)
  406.         IF (hd^.hd.n>0) AND (hd^.hd.n<=usedBeg) THEN
  407.           RETURN storageNext2
  408.         END;
  409.  
  410.         (* Aktueller Zeiger + Platz für Daten muß < nächster Zeiger sein: *)
  411.         IF (hd^.hd.n>0) AND (usedBeg+hd^.size>=hd^.hd.n) THEN
  412.           RETURN storageSize2
  413.         END;
  414.  
  415.         freeBeg:= usedBeg + HeadSize + sizeHd (bl, usedBeg);
  416.         usedBeg:= nextHd (bl, usedBeg)
  417.       END (* LOOP 2 *)
  418.  
  419.     END; (* IF ~full *)
  420.  
  421.     (* Endlosschleife? *)
  422.     INC (count);
  423.     IF count=MAX(CARDINAL) THEN RETURN storageCircle1 END;
  424.   END; (* LOOP 1 *)
  425. END TestStorage;
  426.  
  427. BEGIN
  428.   More ($4EF3, ADR (RootPtr));
  429. END StorUtils.
  430.